home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / clue.lha / clue / examples / old / button.l < prev    next >
Encoding:
Text File  |  1989-07-12  |  6.6 KB  |  206 lines
  1. ;;; -*- Mode:Lisp; Package:CLUE-EXAMPLES; Base:10; Lowercase:T; Syntax:Common-Lisp -*-
  2.  
  3. ;;;
  4. ;;;             TEXAS INSTRUMENTS INCORPORATED
  5. ;;;                  P.O. BOX 2909
  6. ;;;                   AUSTIN, TEXAS 78769
  7. ;;;
  8. ;;; Copyright (C) 1987 Texas Instruments Incorporated.
  9. ;;;
  10. ;;; Permission is granted to any individual or institution to use, copy, modify,
  11. ;;; and distribute this software, provided that this complete copyright and
  12. ;;; permission notice is maintained, intact, in all copies and supporting
  13. ;;; documentation.
  14. ;;;
  15. ;;; Texas Instruments Incorporated provides this software "as is" without
  16. ;;; express or implied warranty.
  17. ;;;
  18.  
  19. (in-package 'clue-examples :use '(lisp xlib clos cluei))
  20.  
  21.  
  22. (export '( label
  23.       justify
  24.       inside-border-width
  25.       button
  26.       notify
  27.       slide-right
  28.       ))
  29.  
  30. (defcontact label (contact)
  31.   ((title :initform nil :type stringable) ;; Defaults to name string
  32.    (style :initform :normal :type (member :normal :box :reverse :box-reverse))
  33.    (justify :initform :center :type (member :left :center :right)
  34.         :accessor button-justify)
  35.    (font :type font)
  36.    (foreground :type pixel)
  37.    (border-width :type card16 :initform 0)
  38.    (inside-border-width :initform 3 :type integer
  39.             :accessor inside-border-width)
  40.    )
  41.   (:resources
  42.     title
  43.     justify
  44.     (font :initform "fg-18")
  45.     foreground
  46.     background
  47.     inside-border-width)
  48.   (:documentation "One line string display in a single font with different styles and justification")
  49.   )
  50.  
  51. (define-resources
  52.   (* label foreground) 1   ;white
  53.   (* label background) 0   ;black
  54.   (* label border) 1       ;white
  55.   )
  56.  
  57. (defmethod initialize-instance :after ((self label) &rest init-plist)
  58.   (declare (ignore init-plist))
  59.   (with-slots (title font height width inside-border-width) self
  60.     (when (symbolp title) ;; NIL is a symbol
  61.       (setf title (string-capitalize (string (or title (contact-name self))))))
  62.     (let ((label-font font))
  63.       (setf height (+ (max-char-ascent label-font)
  64.                (max-char-descent label-font)
  65.                (* 2 inside-border-width)
  66.                2))
  67.       (setf width (+ 2 (text-width label-font title))))))
  68.  
  69. (defmethod display ((self label) &optional x y width height &key)
  70.   (declare (ignore x y width height))
  71.   (with-slots (font title justify inside-border-width style
  72.             (contact-height height) (contact-width width)
  73.             (label-foreground foreground) (label-background background)) self
  74.     (let* ((label-font font)
  75.        (descent (max-char-descent label-font))
  76.        (string title)
  77.        (x 0)
  78.        (y (+ descent (floor contact-height 2))))
  79.       (case justify
  80.     (:left nil)
  81.     (:center (setq x (floor (- contact-width (text-width label-font string)) 2)))
  82.     (:right (setq x (- contact-width (text-width label-font string)))))
  83.       (let ((fore label-foreground)
  84.         (back label-background)
  85.         (inside-border nil))
  86.     (when (member style '(:reverse :box-reverse))
  87.       (rotatef fore back))
  88.     (when (member style '(:box :box-reverse))
  89.       (setq inside-border inside-border-width))
  90.     (using-gcontext (gc :drawable (contact-root self) :foreground back)
  91.       (draw-rectangle self gc 0 0 contact-width contact-height :fill))
  92.     (using-gcontext (gc :drawable (contact-root self)
  93.                 :font label-font
  94.                 :foreground fore :background back
  95.                 :line-width inside-border)
  96.       (when inside-border
  97.         (let ((half (floor inside-border 2)))
  98.           (draw-rectangle self gc half half
  99.                   (- contact-width inside-border)
  100.                   (- contact-height inside-border))))
  101.       (draw-glyphs self gc x y string)
  102.       )))))
  103.  
  104.  
  105. ;;;-----------------------------------------------------------------------------
  106. ;;; BUTTON
  107.  
  108. (defcontact button (label)
  109.   ((command-key :initform nil :type (or null character list))
  110.    (selected :initform nil :type boolean :accessor selected)
  111.    (highlighted :initform nil :type boolean :accessor highlighted)
  112.    )
  113.   (:resources
  114.     (event-mask :initform '(:exposure :owner-grab-button))
  115.     (select :initform nil :type (or null symbol function list))
  116.     (doit   :initform nil :type (or null symbol function list))
  117.     command-key)
  118.   )
  119.  
  120. (defmethod initialize-instance :after ((self button) &key select doit &allow-other-keys)
  121.   (with-slots (callbacks command-key) self
  122.     (when (and select (not (assoc :select callbacks)))
  123.       (push (if (functionp select)
  124.         (list ':select (list select))
  125.           (cons ':select select))
  126.         callbacks))
  127.     (when (and doit (not (assoc :doit callbacks)))
  128.       (push (if (functionp doit)
  129.         (list ':doit (list doit))
  130.           (cons ':doit doit))
  131.         callbacks))
  132.     (when command-key
  133.       (if (atom command-key)
  134.       (add-event self `(:key-press ,command-key) '(display :select :toggle))
  135.     (add-event self `(:key-press ,@command-key) '(display :select :toggle))))))
  136.  
  137. (define-resources
  138.   (* button foreground) 1  ;white
  139.   (* button background) 0  ;black
  140.   (* button border) 1      ;white
  141.   )
  142.  
  143. (defevent button :button-press (action-display :select :toggle))
  144. (defevent button :button-release notify (action-display :select nil :highlight nil))
  145. (defevent button :enter-notify (action-display :highlight t))
  146. (defevent button :leave-notify slide-right (action-display :select nil :highlight nil))
  147.  
  148. (defmethod action-display ((button button) &key (select :unspecified) (highlight :unspecified)) 
  149.   (declare (ignore x y width height))
  150.   (with-slots (style selected highlighted) button
  151.     (case select                ;Set SELECTED
  152.       (:unspecified)
  153.       (:toggle (setf selected (not selected)))
  154.       (otherwise (setf selected select)))
  155.     (unless (eq highlight :unspecified)        ;Set HIGHLIGHTED
  156.       (setf highlighted highlight))
  157.     (let ((old-style style))
  158.       (setf style                ;Set STYLE
  159.         (if highlighted
  160.         (if selected
  161.             :box-reverse
  162.           :box)
  163.           (if selected
  164.           :reverse
  165.         :normal)))
  166.       (unless (eq style old-style)        ;Redisplay when changed
  167.     (display button)))))
  168.  
  169. (defmethod notify ((button button) &optional (callback :select))
  170.   (with-slots (selected) button
  171.     (with-event (x y)
  172.       (when (and selected
  173.          callback
  174.          (inside-contact-p button x y))
  175.     (apply-callback button callback)))))
  176.  
  177. (defmethod slide-right ((button button) &optional (callback :cascade) )
  178.   ;; Hook for cascading menus.  Apply CALLBACK when mouse is to the right of BUTTON.
  179.   (let (t1 t2)
  180.     (with-slots (width height selected) button
  181.       (with-event (x y)
  182.     (setq t1 (and selected
  183.                 callback
  184.                 (and (< 0 x)
  185.                  (< 0 y height))))
  186.       ;; Select button with the results from the cascade callback
  187.     (setq t2 (callback-p button callback))
  188.     (if (and t1 t2)
  189.         (progn (delete-callback (contact-parent button) :leave)
  190.            (apply-callback button :select
  191.                    (apply-callback button callback)))
  192.  
  193.         (add-callback (contact-parent button) :leave #'cascade-exit (contact-parent button) ))))))
  194.  
  195.  
  196.  
  197.  
  198.  
  199.  
  200.                                     
  201.  
  202.  
  203.  
  204.  
  205.  
  206.